home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Library / apropos-smart.lisp next >
Encoding:
Text File  |  1987-11-05  |  22.3 KB  |  487 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;apropos-smart.Lisp
  3. ;;
  4. ;;copyright 1987, Coral Software Corp
  5. ;;
  6. ;;  This file implements the fancy apropos dialog which was included in
  7. ;;  Allegro CL version 1.0.
  8. ;;
  9. ;;  If you prefer the fancy apropos dialog, load this file.  The action of
  10. ;;  the Apropos… menu-item will be changed.
  11. ;;
  12. ;;
  13.  
  14. (defun apropos-smart (&key (string "") 
  15.                (packages :dont-care) (first-characters :dont-care) 
  16.                (binding-types :dont-care) (and-fn-var? nil)
  17.                (symbol-types '(:internal :inherited :external)) 
  18.                (upper-case-string? nil)
  19.                (print-incrementally? nil) (return-list? t)
  20.               &aux result constant? variable? function? macro? special-form?
  21.                    not-bound? not-fbound? first-char
  22.                    sym-name)
  23.   "If return-list? is NIL, but apropos-smart finds some symbols, return T.
  24.    Thus apropos-smart returns NIL only if it finds no symbols."
  25.   (if (eq packages :dont-care)
  26.       (setq packages (list-all-packages)))
  27.   (if upper-case-string?
  28.       (setq string (string-upcase string)))
  29.   (cond ((not (eq binding-types :dont-care))
  30.          (if (memq :variable binding-types)
  31.               (setq variable? t))
  32.          (if (memq :constant binding-types)
  33.              (setq constant? t))
  34.          (if (memq :not-bound binding-types)
  35.              (setq not-bound? t))
  36.  
  37.          (if (memq :function binding-types)
  38.              (setq function? t))
  39.          (if (memq :macro binding-types)
  40.              (setq macro? t))
  41.          (if (memq :special-form binding-types)
  42.              (setq special-form? t))
  43.          (if (memq :not-fbound binding-types)
  44.              (setq not-fbound? t))
  45.          ))
  46.   (dolist (package packages)
  47.       (do-symbols (sym package)
  48.         (setq sym-name (symbol-name sym))
  49.         (if (and  (ccl::%apropos-substring-p string sym-name)
  50.                   (or (eq binding-types :dont-care) ;includes unbound
  51.                       (and (not and-fn-var?) ;or everything
  52.                        (or
  53.                         (and function? (fboundp sym) 
  54.                                        (not (special-form-p sym))
  55.                                        (not (macro-function sym)))
  56.                         (and macro? (macro-function sym))
  57.                         (and special-form? (special-form-p sym))
  58.                         (and not-fbound? (not (fboundp sym)))
  59.                       
  60.                         (and variable? (boundp sym) (not (constantp sym)))
  61.                         (and constant? (constantp sym))
  62.                         (and not-bound? (not (boundp sym)))
  63.                       ))
  64.                       (and (or
  65.                               (and function? (fboundp sym) (not (special-form-p sym))
  66.                                                    (not (macro-function sym)))
  67.                               (and macro? (macro-function sym))
  68.                               (and special-form? (special-form-p sym))
  69.                               (and not-fbound? (not (fboundp sym)))
  70.                               )
  71.                            (or 
  72.                               (and variable? (boundp sym) (not (constantp sym)))
  73.                               (and constant? (constantp sym))
  74.                               (and not-bound? (not (boundp sym)))
  75.                               )
  76.                         ))
  77.                   (multiple-value-bind (ignore sym-type) 
  78.                                        (find-symbol sym-name package)
  79.                         (memq sym-type symbol-types))
  80.             
  81.                   (or (eq first-characters :dont-care)
  82.                       (progn 
  83.                         (setq first-char (if (> (length sym-name) 0) 
  84.                                              (aref (symbol-name sym) 0)))
  85.                         (cond (first-char ;watch out for "" name.
  86.                                 (cond ((and (alpha-char-p first-char)
  87.                                             (upper-case-p first-char))
  88.                                        (setq first-char 'upper-alpha))
  89.                                       ((not (memq first-char 
  90.                                                   '(#\_ #\% #\* #\&)))
  91.                                        (setq first-char 'other)))
  92.                                 (memq first-char first-characters)))))
  93.                   )
  94.             (progn
  95.               (if return-list? 
  96.                 (push sym result))
  97.               (if print-incrementally?
  98.                  (progn (apropos-smart-symbol-print sym)
  99.                         (setq result t)))
  100.               )
  101.             )))
  102.   (if (eq result t)
  103.     (format t "? ")
  104.     )
  105.   result)
  106.  
  107. (defun apropos-smart-symbol-print (sym)
  108.    (format t "~S   " sym)
  109.    (if (boundp sym)
  110.      (cond ((constantp sym)
  111.             (format t "constant value: ~S" (eval sym)))
  112.            (t (format t "value: ~S" (eval sym)))))
  113.    (cond ((special-form-p sym)
  114.            (format t "special form"))
  115.          ((macro-function sym)
  116.           (format t "macro"))
  117.          ((fboundp sym)
  118.           (format t "function")))
  119.    (terpri))
  120.         
  121.  
  122. (defvar %apropos-smart-dialog)
  123.  
  124. (setq %apropos-smart-dialog
  125.  (let* ((the-dialog (oneof *dialog*
  126.                          :window-title "Apropos"
  127.                          :window-show nil
  128.                          :window-position #@(8 26)
  129.                          :window-size #@(366 309)
  130.                          :procid 1 
  131.                          )))
  132.    (ask the-dialog (add-dialog-items
  133.                     (oneof
  134.                      *static-text-dialog-item*
  135.                      :dialog-item-text "Apropos"
  136.                      :dialog-item-position #@(142 -1)
  137.                      :dialog-item-size  #@(59 16))     
  138.                     (oneof
  139.                      *static-text-dialog-item*
  140.                      :dialog-item-text "Value Binding Types"
  141.                      :dialog-item-position #@(3 15)
  142.                      :dialog-item-size #@(133 16))
  143.                     (have 'unbound-item
  144.                           (oneof
  145.                            *check-box-dialog-item*
  146.                            :dialog-item-text "unbound"
  147.                            :Dialog-item-position #@(19 69)
  148.                            :dialog-item-size #@(76 16)
  149.                            :check-box-checked-p nil))
  150.                     (have 'variable-item
  151.                           (oneof
  152.                            *check-box-dialog-item*
  153.                            :dialog-item-text "variable"
  154.                            :dialog-item-position #@(19 34)
  155.                            :dialog-item-size #@(81 16)
  156.                            :check-box-checked-p t))
  157.                     (have 'constant-item
  158.                           (oneof
  159.                            *check-box-dialog-item*
  160.                            :dialog-item-text "constant"
  161.                            :dialog-item-position #@(19 52)
  162.                            :dialog-item-size #@(85 16)
  163.                            :check-box-checked-p t))
  164.                     (have 'and-item
  165.                           (oneof
  166.                            *radio-button-dialog-item*
  167.                            :dialog-item-text "and"
  168.                            :dialog-item-position #@(3 95)
  169.                            :dialog-item-size #@(44 16)
  170.                            :radio-button-cluster 'and-or
  171.                            :radio-button-pushed-p nil))
  172.                     (have 'or-item
  173.                           (oneof
  174.                            *radio-button-dialog-item*
  175.                            :dialog-item-text "or"
  176.                            :dialog-item-position #@(59 94)
  177.                            :dialog-item-size #@(34 16)
  178.                            :radio-button-cluster 'and-or
  179.                            :radio-button-pushed-p t))
  180.                     (oneof
  181.                      *static-text-dialog-item*
  182.                      :dialog-item-text "Function Binding Types"
  183.                      :dialog-item-position #@(3 117)
  184.                      :dialog-item-size #@(153 16))
  185.                     (have 'function-item
  186.                           (oneof
  187.                            *check-box-dialog-item*
  188.                            :dialog-item-text "function"
  189.                            :dialog-item-position #@(20 135)
  190.                            :dialog-item-size #@(75 16)
  191.                            :check-box-checked-p t))
  192.                     (have 'macro-item
  193.                           (oneof
  194.                            *check-box-dialog-item*
  195.                            :dialog-item-text "macro"
  196.                            :dialog-item-position #@(20 154)
  197.                            :dialog-item-size #@(61 16)
  198.                            :check-box-checked-p t))
  199.                     (have 'special-form-item
  200.                           (oneof
  201.                            *check-box-dialog-item*
  202.                            :dialog-item-text
  203.                            "special form"
  204.                            :dialog-item-position #@(20 173)
  205.                            :dialog-item-size #@(102 16)
  206.                            :check-box-checked-p t))
  207.                     (have 'unfbound-item
  208.                           (oneof
  209.                            *check-box-dialog-item*
  210.                            :dialog-item-text "unfbound"
  211.                            :dialog-item-position #@(20 193)
  212.                            :dialog-item-size #@(82 16)
  213.                            :check-box-checked-p nil))
  214.                     (oneof
  215.                      *static-text-dialog-item*
  216.                      :dialog-item-text "Substring"
  217.                      :dialog-item-position #@(7 220)
  218.                      :dialog-item-size  #@(66 16))
  219.                     (have 'substring-item                           
  220.                           (oneof
  221.                            *editable-text-dialog-item*
  222.                            :dialog-item-text ""
  223.                            :dialog-item-position #@(8 239)
  224.                            :dialog-item-size #@(164 16)
  225.                            :allow-returns nil))
  226.                     (have 'upper-case-substring-item
  227.                           (oneof
  228.                            *check-box-dialog-item*
  229.                            :dialog-item-text "upper-case substring"
  230.                            :dialog-item-position #@(4 262)
  231.                            :dialog-item-size #@(164 16)
  232.                            :check-box-checked-p t))
  233.                     (have 'the-default-button
  234.                           (oneof
  235.                            *button-dialog-item*
  236.                            :dialog-item-text "OK"
  237.                            :dialog-item-position #@(250  286)
  238.                            :dialog-item-size #@(46 17)
  239.                            :dialog-item-action 
  240.                            '(return-from-modal-dialog t)))
  241.                     (oneof
  242.                      *button-dialog-item*
  243.                      :dialog-item-text "Cancel"
  244.                      :dialog-item-position #@(307 288)
  245.                      :dialog-item-size #@(53 16)
  246.                      :dialog-item-action 
  247.                      '(return-from-modal-dialog nil))
  248.                     (have '&-item
  249.                           (oneof
  250.                            *check-box-dialog-item*
  251.                            :dialog-item-text "&"
  252.                            :dialog-item-position  #@(225 239)
  253.                            :dialog-item-size #@(30 16)
  254.                            :check-box-checked-p t))
  255.                     (have '_-item
  256.                           (oneof
  257.                            *check-box-dialog-item*
  258.                            :dialog-item-text "_"
  259.                            :dialog-item-position #@(226 259)
  260.                            :dialog-item-size #@(28 16)
  261.                            :check-box-checked-p t))
  262.                     (have '*-item
  263.                           (oneof
  264.                            *check-box-dialog-item*
  265.                            :dialog-item-text "*"
  266.                            :dialog-item-position #@(192 239)
  267.                            :dialog-item-size #@(27 16)
  268.                            :check-box-checked-p t))
  269.                     (have '%-item
  270.                           (oneof
  271.                            *check-box-dialog-item*
  272.                            :dialog-item-text "%"
  273.                            :dialog-item-position #@(192 259)
  274.                            :dialog-item-size #@(31 16)
  275.                            :check-box-checked-p  t))
  276.                     (have 'upper-alphas-item
  277.                           (oneof
  278.                            *check-box-dialog-item*
  279.                            :dialog-item-text  "upper-alphas"
  280.                            :dialog-item-position #@(260 239)
  281.                            :dialog-item-size #@(108 16)
  282.                            :check-box-checked-p t))
  283.                     (have 'others-item
  284.                           (oneof
  285.                            *check-box-dialog-item*
  286.                            :dialog-item-text "others"
  287.                            :dialog-item-position #@(260 259)
  288.                            :dialog-item-size #@(63 16)
  289.                            :check-box-checked-p t))
  290.                     (oneof
  291.                      *static-text-dialog-item*
  292.                      :dialog-item-text "First Character"
  293.                      :dialog-item-position #@(200 220)
  294.                      :dialog-item-size #@(103 16))
  295.                     (oneof
  296.                      *static-text-dialog-item*
  297.                      :dialog-item-text "Packages"
  298.                      :dialog-item-position #@(224 15)
  299.                      :dialog-item-size #@(82 16))
  300.                     (have 'inherited-item
  301.                           (oneof
  302.                            *check-box-dialog-item*
  303.                            :dialog-item-text "inherited"
  304.                            :dialog-item-position #@(221 150)
  305.                            :dialog-item-size #@(80 16)
  306.                            :check-box-checked-p nil)) ;if not nil and you
  307.                     ;have lots of pkgs selected, you'll get duplications in the
  308.                     ;output symbols, which take too much time to remove
  309.                     (have 'internal-item
  310.                           (oneof
  311.                            *check-box-dialog-item*
  312.                            :dialog-item-text "internal"
  313.                            :dialog-item-position #@(221 171)
  314.                            :dialog-item-size  #@(72 16)
  315.                            :check-box-checked-p t))
  316.                     (have 'external-item
  317.                           (oneof
  318.                            *check-box-dialog-item*
  319.                            :dialog-item-text "external"
  320.                            :dialog-item-position #@(221 192)
  321.                            :dialog-item-size #@(76 16)
  322.                            :check-box-checked-p t))
  323.                     (have 'sort-output-item
  324.                           (oneof
  325.                            *check-box-dialog-item*
  326.                            :dialog-item-text "sort output"
  327.                            :dialog-item-position #@(3 286)
  328.                            :dialog-item-size #@(95 16)
  329.                            :check-box-checked-p  nil))
  330.                     (have 'print-item
  331.                           (oneof
  332.                            *radio-button-dialog-item*
  333.                            :dialog-item-text "print"
  334.                            :dialog-item-position #@(108 286)
  335.                            :dialog-item-size #@(52 16)
  336.                            :radio-button-cluster 'output
  337.                            :radio-button-pushed-p t))
  338.                     (have 'inspect-item
  339.                           (oneof
  340.                            *radio-button-dialog-item*
  341.                            :dialog-item-text "inspect"
  342.                            :dialog-item-position #@(164 286)
  343.                            :dialog-item-size #@(68 16)
  344.                            :radio-button-cluster 'output
  345.                            :radio-button-pushed-p nil))
  346.                     (have 'packages-item
  347.                           (oneof
  348.                            *sequence-dialog-item*
  349.                            :table-sequence                                  
  350.                            (mapcar #'package-name (list-all-packages))
  351.                            :dialog-item-position #@(224 33)
  352.                            :dialog-item-size #@(130 111)
  353.                            :selection-type :disjoint
  354.                            :cell-size #@(115 16)))
  355.                     ))
  356.   (ask the-dialog
  357.        (set-default-button the-default-button))
  358.   (dotimes (i (length (list-all-packages)))
  359.            (ask (ask the-dialog packages-item)
  360.                 (cell-select (make-point 0 i))))
  361.   the-dialog))
  362.  
  363. (defobfun (window-show %apropos-smart-dialog) ()
  364.   (declare (object-variable packages-item))
  365.   (ask packages-item
  366.     (set-table-sequence (mapcar #'package-name (list-all-packages))))
  367.   (usual-window-show))
  368.  
  369.  
  370. (defun apropos-smart-dialog (&aux (asd %apropos-smart-dialog) selection 
  371.                                 the-substring 
  372.                                 pkg-item packages first-chars binding-types
  373.                                 symbol-types print? sort? result-symbols)
  374.   (declare (object-variable substring-item packages-item &-item _-item *-item
  375.                             %-item upper-alphas-item others-item variable-item
  376.                             constant-item unbound-item function-item macro-item
  377.                             special-form-item unfbound-item inherited-item
  378.                             internal-item external-item print-item
  379.                             sort-output-item and-item
  380.                             upper-case-substring-item))
  381.   (setq selection (if (typep (front-window) *fred-window*)
  382.                     (ask (front-window) (get-selected-string))))
  383.   (if selection (ask (ask asd substring-item) (set-dialog-item-text selection)))
  384.   (cond ((modal-dialog asd nil) ;user didn't cancel out of dialog
  385.          (setq the-substring (ask (ask asd substring-item)                       
  386.                                     (dialog-item-text)))
  387.          (setq pkg-item (ask asd packages-item))
  388.          (setq packages (ask pkg-item 
  389.                           (mapcar #'cell-contents (selected-cells))))
  390.          (if (ask (ask asd &-item)
  391.                                (check-box-checked-p))
  392.              (push #\& first-chars))
  393.          (if (ask (ask asd _-item)
  394.                                (check-box-checked-p))
  395.              (push #\_ first-chars))
  396.          (if (ask (ask asd *-item)
  397.                                (check-box-checked-p))
  398.              (push #\* first-chars))
  399.          (if (ask (ask asd %-item)
  400.                                (check-box-checked-p))
  401.              (push #\% first-chars))
  402.          (if (ask (ask asd upper-alphas-item)
  403.                                (check-box-checked-p))
  404.              (push 'upper-alpha first-chars))
  405.          (if (ask (ask asd others-item)
  406.                                (check-box-checked-p))
  407.              (push 'other first-chars))
  408.          (if (ask (ask asd variable-item)
  409.                                (check-box-checked-p))
  410.              (push :variable binding-types))
  411.           (if (ask (ask asd constant-item)
  412.                                (check-box-checked-p))
  413.              (push :constant binding-types))
  414.           (if (ask (ask asd unbound-item)
  415.                                (check-box-checked-p))
  416.              (push :not-bound binding-types))
  417.           (if (ask (ask asd function-item)
  418.                                (check-box-checked-p))
  419.              (push :function binding-types))
  420.            (if (ask (ask asd macro-item)
  421.                                (check-box-checked-p))
  422.              (push :macro binding-types))
  423.          (if (ask (ask asd special-form-item)
  424.                                (check-box-checked-p))
  425.              (push :special-form binding-types))
  426.          (if (ask (ask asd unfbound-item)
  427.                                (check-box-checked-p))
  428.              (push :not-fbound binding-types))
  429.          (if (ask (ask asd inherited-item)
  430.                                (check-box-checked-p))
  431.              (push :inherited symbol-types))
  432.          (if (ask (ask asd internal-item)
  433.                                (check-box-checked-p))
  434.              (push :internal symbol-types))
  435.          (if (ask (ask asd external-item)
  436.                                (check-box-checked-p))
  437.              (push :external symbol-types))
  438.          (setq print? (ask (ask asd print-item)
  439.                                (radio-button-pushed-p)))
  440.          (setq sort? (ask (ask asd sort-output-item)
  441.                                (check-box-checked-p)))
  442.          (setq result-symbols
  443.           (apropos-smart 
  444.            :string the-substring
  445.            :packages packages
  446.            :first-characters first-chars
  447.            :binding-types binding-types
  448.            :and-fn-var? (ask (ask asd and-item)
  449.                           (radio-button-pushed-p))
  450.            :symbol-types symbol-types
  451.            :upper-case-string? (ask (ask asd upper-case-substring-item)
  452.                                (check-box-checked-p))
  453.            :print-incrementally? (and print? (not sort?))
  454.            :return-list?         (or sort? (not print?))
  455.            )) ;returns NIL, T or a list of symbols
  456.          (cond ((eq result-symbols t) ;symbols were found and printed
  457.                 )
  458.                ((eq result-symbols nil) ; no symbols found
  459.                 (message-dialog "No symbols match the APROPOS pattern."))
  460.                (t ;got some symbols that need to be output
  461.                 (if sort?
  462.                   (setq result-symbols 
  463.                         (sort result-symbols #'string< :key #'symbol-name)))                                            
  464.                 (if print? ;must not have been previously printed,
  465.                            ;presumably because they needed sorting.
  466.                   (progn 
  467.                   (mapcar #'apropos-smart-symbol-print result-symbols)
  468.                   (format t "? ")
  469.                   )
  470.                   (inspect result-symbols))
  471.                 ))
  472.             )))
  473.  
  474. (let ((apropos-menu-item (ask *tools-menu* (find-menu-item "Apropos…"))))
  475.   (if apropos-menu-item
  476.     (defobfun (menu-item-action apropos-menu-item) ()
  477.       (apropos-smart-dialog))
  478.     (ask *tools-menu* (add-menu-items
  479.                        (oneof *menu-item*
  480.                               :menu-item-title "-")
  481.                        (oneof *menu-item* 
  482.                               :menu-item-title "Apropos Smart…"
  483.                               :menu-item-action #'apropos-smart-dialog)))))
  484.  
  485.  
  486. (provide 'apropos-smart)
  487. (pushnew :apropos-smart *features*)